home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Ham Radio 2000
/
Ham Radio 2000.iso
/
ham2000
/
bbs
/
diebox19
/
rstat.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-10-14
|
7KB
|
279 lines
{ Ausgabe eine Auslesestatistik fuer DIEBOX anhand von RLOG.BOX }
{ Version 0.2 - DL1MCX @ OE9XPI }
Program RStat;
Uses Crt, Dos;
Const
MaxDir = 1024;
NoError = 0;
OpenError = 1;
Type
AnyStr = String[255];
DirRec = Record
Board : String[8];
count : Word;
End;
DirPtr = ^DirRec;
DirArr = Array[1..MaxDir] of DirPtr;
LessFunc = function(X, Y: DirPtr):Boolean;
Var
Con,
RFile : Text;
Pfad,
LogBegin,
LogEnd : AnyStr;
returncode : byte;
Dir : DirArr;
Count,RCount : Word;
Less : LessFunc;
{-------------------------------------------------------------------------
ConstStr fuellt einen String auf die Gesamtlaenge L mit Zeichen ch auf;
Fuer Posi wird "r" oder "l" erwartet (rechts- oder linksbuendig)
--------------------------------------------------------------------------}
FUNCTION ConstStr (Zeile:String; L:Integer; ch, Posi:Char) : String;
Var B_Str : String;
Laenge : Byte;
BEGIN
Laenge := L - length(Zeile);
IF (L < 0 ) THEN L := 0;
IF (L > 255) THEN L := 255;
fillchar(B_Str,Laenge+2,ch);
B_Str[0] := Chr(Laenge);
If Posi = 'l'
then ConstStr := Zeile + B_Str;
IF Posi = 'r'
then ConstStr := B_Str + Zeile;
END;
{------------------------------------------------------------------------------
isCall prüft, ob RUBRIK ein Call oder 'ne Rubrik ist
+-----------------------------------------------------------------------------}
FUNCTION isCall (Rubrik : String ): Boolean;
const
digit = ['0'..'9'];
var
i : shortint;
ok : boolean;
count : shortint;
suffix : shortint;
begin
ok := false;
suffix := 0;
count := length (Rubrik);
if count in [2..7]
then
for i:=1 to 3 do
begin
if ( Rubrik [i] in digit )
and ( i in [2,3] )
then ok := true
end;
if ok then
if ( Rubrik [1] in digit ) and
( Rubrik [2] in digit )
then ok := false; (* keine Calls mit 2 führenden Ziffern *)
if ok then
for i:=count downto 1 do
if not ( Rubrik [i] in digit )
then inc (suffix);
if ok and ( suffix < 5 ) then
if not ( Rubrik [count] in digit ) then
ok := true
else ok := false;
isCall := ok;
end;
{-----------------------------------------------------------------------
Sortierfunktionen
-----------------------------------------------------------------------}
{$F+}
(* numerisch sortieren *)
function MoreCount(X, Y : DirPtr): Boolean;
begin
MoreCount := X^.Count > Y^.Count;
end;
{$F-}
{----------------------------------------------------------------------
QuickSort Sortieralgorithmus
----------------------------------------------------------------------}
procedure QuickSort(L, R: Integer);
var
I, J: Integer;
X, Y: DirPtr;
Z : DirPtr;
begin
I := L;
J := R;
X := Dir[(L + R) div 2];
repeat
while Less(Dir[I], X) do Inc(I);
while Less(X, Dir[J]) do Dec(J);
if I <= J then
begin
Y := Dir[I];
Dir[I] := Dir[J];
Dir[J] := Y;
Inc(I);
Dec(J);
end;
until I > J;
if L < J then QuickSort(L, J);
if I < R then QuickSort(I, R);
end;
{------------------------------------------------------------------------------
Take_Pfad holt den Pfad
+-----------------------------------------------------------------------------}
PROCEDURE Take_Pfad(Var Pfad : Anystr);
Var
Zeile : Anystr;
BEGIN
Pfad := GetEnv('MB_DIR') + 'PROTO\';
END;
{------------------------
OpenRFile oeffen LogFile
------------------------}
Function OpenRFile : Byte;
Begin
ASSIGN(RFile,pfad + 'RLOG.BOX');
{$I-} RESET(RFile); {$I+}
IF IOResult <> 0
then OpenRFile := OpenError
else
OpenRFile := noerror;
End;
{-------------------------------------
ReadRFile liest Daten aus Logfile ein
-------------------------------------}
Procedure ReadRFile;
Var
i,z : Word;
Zeile : AnyStr;
Board : String[12];
found : boolean;
Begin
i := 0;
While (not EOF(RFile) and (i < MaxDir)) do
begin
Readln(RFile,Zeile);
(*
1 22.06.92 00:18 DL1MCX: IBM 1 ZBPKNL
*)
if i = 0 then LogBegin := Copy(Zeile,4,14);
Board := Copy(Zeile,27,9);
Board := Copy(Board,1,Pos(' ',Board)-1);
If (not(iscall(Board)) and (length(Board) > 1)) then
begin
inc(RCount);
found := false;
z := 1;
While ((z <= i) and (not found)) do
begin
If Dir[z]^.Board = Board then
begin
found := true;
inc(Dir[z]^.count);
end;
inc(z);
end;
If (not found) then
begin
inc(i);
If (MaxAvail < SizeOf(DirRec))
then
begin
Writeln(Con,#13#10'Nicht genügend Speicher, Programm abgebrochen');
close(RFile);
close(con);
halt;
end
else
begin
New(Dir[i]);
Dir[i]^.Board := Board;
Dir[i]^.count := 1;
end;
end;
end;
End;
LogEnd := Copy(Zeile,4,14);
Count := i;
if (i = MaxDir) then
writeln(con,#13#10'Speichermangel - Daten unvollständig !');
Close(RFile);
End;
{------------------------
WriteStat gibt Liste aus
------------------------}
Procedure WriteStat;
Var
i : Word;
c : Byte;
match : Word;
Board : String[12];
CountStr: String[6];
Outline : AnyStr;
Begin
c := 1;
For i := 1 to Count do
begin
Board := Dir[i]^.Board;
Str(Dir[i]^.Count,CountStr);
Outline := ConstStr(Board,(13-length(CountStr)),'.','l') + CountStr + ' ';
Write(Con,OutLine);
inc(c);
if c = 6 then
begin
Writeln(Con);
c := 1;
end;
end;
Writeln(Con);
Writeln(Con,'Gesamt: ',RCount);
End;
Begin
DirectVideo := False;
RCount := 0;
Less := MoreCount;
ASSIGN(Con,'');
REWRITE(Con);
Write(Con,#13#10'RStat v0.2 (DL1MCX)');
Take_Pfad(Pfad);
Returncode := OpenRFile;
if Returncode = noerror then
begin
ReadRFile;
Writeln(Con,' - Statistik vom ',Logbegin,' bis ',LogEnd,#13#10);
quicksort (1,Count);
WriteStat;
end;
Writeln(Con);
Close(Con);
End.